Night Owl 6/Night Owl's Shareware - PDSI-006 - Night Owl Corp (1990).iso/037a/tpfast40.zip/T_FILE.PAS

Pascal/Delphi Source File | 1991-11-15 | 6KB | 205 lines

{ -------------------------------------------------------------------------- }
{                                 t_file.pas                                 }
{                      demo of file  functions for TPFAST                    }
{ -------------------------------------------------------------------------- }
uses dos,crt,tpfast;

type
      userrec = record
                 name      :string[18];
                 address   :string[40];
                 phone     :string[14];
               end;


const
      maxrecs     = 5;           { maximum records }
      fname       = 'test.rec';  { sample file name }

      f_read      = 0;       { used in fopen }
      f_write     = 1;       { ditto }
      f_readwrite = 2;       { ditto }

      readonly    = 1;       { already defined standard run-time }
      hidden      = 2;       { use logical OR for combined file attributes }
      sysfile     = 4;
      volumeid    = 8;
      directory   = 16;
      archive     = 32;

var
      ch        :char;
      testrecs  :array [1..maxrecs] of userrec;


{ -------------------------------------------------------------------------- }
procedure errorexit(msg :string);

begin
    writeln('Error -',msg);
    halt(1);
end;

{ -------------------------------------------------------------------------- }
procedure maketestarray;

begin

with testrecs[1] do
 begin
   name    := 'Eddy Murphey';
   address := '33 Holywood ave';
   phone   := '132-3346';
 end;
with testrecs[2] do
 begin
   name    := 'Jack Frost';
   address := '11 Omeo road Mount Hotham';
   phone   := '054-230-1306';
 end;
with testrecs[3] do
 begin
   name    := 'Indiana Jones';
   address := '44 Hospital avenue Egypt';
   phone   := '991-3127';
 end;
with testrecs[4] do
 begin
   name    := 'Jenny Morris';
   address := '9 Music house raod Australia';
   phone   := '[phone]';
 end;
with testrecs[5] do
 begin
   name    := 'Ivan Ackerman';
   address := '40 Woody allen bollevard Coloreado';
   phone   := '(291)-345-6729';
 end;
end;

{ -------------------------------------------------------------------------- }
procedure maketestfile;

var
  f                        :integer;
  numwritten,loop          :integer;

begin
  writeln('[ Making test file  ....         ]');
  maketestarray;                                   { init array with names }
  f := fcreate(fname,archive);                     { create the file }
  case (f) of
     -3  : errorexit('path not found');
     -4  : errorexit('too many open files');
     -5  : errorexit('access denied');
   end;

  for loop := 1 to maxrecs do
    numwritten := fwrite(f,sizeof(testrecs[loop]),testrecs[loop]);
  if (fclose(f) = false) then
      writeln('Unable to close file ',fname);
end;

{ -------------------------------------------------------------------------- }
procedure readtestfile;

var
  f,numread           :integer;
  buf                 :userrec;

begin
  writeln('[ Reading test file ....         ]');
  writeln;
  f := fopen(fname,0);                               { open for reading }
  repeat
    numread := fread(f,sizeof(buf),buf);             { read one record }
    if (numread > 0) then                            { if read OK }
      writeln(buf.name:18,buf.address:40,buf.phone:16);
  until (numread <= 0);

  if (fclose(f) = false) then                        { close file }
      writeln('Unable to close file ',fname);        { check if OK }
end;


{ -------------------------------------------------------------------------- }
procedure  appendrec;

var
      f                   :integer;
      pos,newpos          :longint;
      buf                 :userrec;
      numwritten          :integer;

begin
writeln('[ Appending a record  ....       ]');
with buf do
 begin                                     { create a temp record }
   name    := 'Darren Bastard';
   address := '99 Horse Court ';
   phone   := '784-2876';
 end;

  f := fopen(fname,1);                     { open for writing }
  if (f < 0 ) then                         { check if OK }
    errorexit('Unable to open file');

  pos := maxrecs * sizeof(buf);            { move to end of file }

  if (fseek(f,0,pos,newpos) = false) then  { check if OK }
       errorexit('Error in FSeek operation ...');

  numwritten := fwrite(f,sizeof(buf),buf);  { write the record }
    if numwritten < sizeof(buf) then        { check if OK }
       errorexit('in appending to file ...');

  if (fclose(f) = false) then               { close file }
    errorexit('Unable to close file.');     { check if OK }
end;

{ -------------------------------------------------------------------------- }
procedure  updaterec(recno :byte);

var
      f                  :integer;
      pos,newpos         :longint;
      buf                :userrec;
      numwritten         :integer;

begin
writeln('Updating record number ',recno,' ....');
with buf do
 begin                                      { create temp record }
   name    := 'Darren Bastard';
   address := '99 Horse Court ';
   phone   := '784-2876';
 end;

  f := fopen(fname,1);                      { open file for reading }
  if (f < 0 ) then                          { check if OK }
    errorexit('Unable to open file');

  pos := recno * sizeof(buf);               { calculate record position }
  if (fseek(f,0,pos,newpos) = false) then   { move to record position }
    errorexit('File seek failed.');

  numwritten := fwrite(f,sizeof(buf),buf);  { write the record }
    if numwritten < sizeof(buf) then        { check if OK }
       errorexit('in appending to file ...');

  if (fclose(f) = false) then               { close file }
    errorexit('Unable to close file.');     { check if OK }
end;

{ -------------------------------------------------------------------------- }
begin
 clrscr;
 maketestfile;
 readtestfile;
 ch := readkey;
 updaterec(2);
 readtestfile;
 ch := readkey;
end.